home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / Pascal / Snippets / PNL Libraries / MyVBLSync.p < prev    next >
Text File  |  1997-05-07  |  2KB  |  105 lines
  1. unit MyVBLSync;
  2.  
  3. interface
  4.  
  5.     var
  6.         vbl_count: longint;
  7.         
  8.     procedure StartupVBLSync;
  9.     procedure SetVBLSyncing( on: boolean );
  10.     function IsVBLSyncing: boolean;
  11.     procedure WaitForSync;
  12.  
  13. implementation
  14.  
  15.     uses
  16.         Types, LowMem, Menus, Timer, Windows, Retrace, Devices, Quickdraw, OSUtils, MixedMode,
  17.         GammaPaslib,
  18.         MyStartup, MyAssertions, MyWindows, MyLowLevel, 
  19.         PreserveA5;
  20.     
  21.     var
  22.         syncing: boolean;
  23.         task: VBLTask;
  24.         vbl_proc: VBLUPP;
  25.         
  26.     procedure RealVBLTask( task: VBLTaskPtr );
  27.     begin
  28.         Inc(vbl_count);
  29.         task^.vblCount := 1;
  30.     end;
  31.  
  32. {$ifc GENERATINGCFM}
  33.     procedure VBLTask( task: VBLTaskPtr );
  34.     begin
  35.         RealVBLTask( task );
  36.     end;
  37. {$elsec}
  38.     procedure VBLTask;
  39.     begin
  40.         RealVBLTask( VBLTaskPtr(GetRegA0) );
  41.     end;
  42. {$endc}
  43.  
  44.     procedure SetVBLSyncing( on: boolean );
  45.         var
  46.             mainDCE: AuxDCEHandle;
  47.             err: OSErr;
  48.     begin
  49.         if syncing <> on then begin
  50.             mainDCE := AuxDCEHandle( GetDCtlEntry( GetMainDevice^^.gdRefNum ) );
  51.             
  52.             if on then begin
  53.                 task.vblAddr := vbl_proc;
  54.                 task.qType := vType;
  55.                 task.vblCount := 1;
  56.                 
  57.                 err := SlotVInstall( @task, mainDCE^^.dCtlSlot );
  58.                 if err = noErr then begin
  59.                     syncing := true;
  60.                 end;
  61.             end else begin
  62.                 err := SlotVRemove( @task, mainDCE^^.dCtlSlot );
  63.                 Inc(vbl_count);
  64.                 syncing := false;
  65.             end;
  66.         end;
  67.     end;
  68.     
  69.     function IsVBLSyncing: boolean;
  70.     begin
  71.         IsVBLSyncing := syncing;
  72.     end;
  73.     
  74.     procedure WaitForSync;
  75.         var
  76.             old_count: longint;
  77.     begin
  78.         old_count := vbl_count;
  79.         while syncing and (vbl_count = old_count) do begin
  80.         end;
  81.     end;
  82.     
  83.     function InitVBLSync( var msg: integer ): OSStatus;
  84.     begin
  85. {$unused(msg)}
  86.         syncing := false;
  87.         vbl_count := 0;
  88.         vbl_proc := NewVBLProc( @VBLTask );
  89.         InitVBLSync := noErr;
  90.     end;
  91.  
  92.     procedure FinishVBLSync;
  93.     begin
  94.         SetVBLSyncing( false );
  95.         DisposeRoutineDescriptor( vbl_proc );
  96.     end;
  97.     
  98.     procedure StartupVBLSync;
  99.     begin
  100.         StartupPreserveA5;
  101.         SetStartup( InitVBLSync, nil, 0, FinishVBLSync );
  102.     end;
  103.     
  104. end.
  105.